home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / CODE / views / histogram-view.lisp next >
Encoding:
Text File  |  1992-09-02  |  5.7 KB  |  177 lines  |  [TEXT/CCL2]
  1. ;;; histogram-view.lisp
  2. ;;;
  3. ;;; Paul McCartney, Spring 1992
  4. ;;;
  5. ;;; Copyright © 1992 Paul McCartney.  All Rights Reserved.
  6. ;;; 
  7. ;;; Washington University Medical Informatics Training Program
  8. ;;;
  9. ;;; DESCRIPTION:
  10. ;;;
  11. ;;; This is a view which displays a histogram in 3D, with the vanishing
  12. ;;; point being the top-middle of the view.
  13. ;;;
  14. ;;; USE:
  15. ;;;
  16. ;;; histogram-view       - view class for histogram view
  17. ;;;   :x-start           - horizontal start value
  18. ;;;   :x-end             - horizontal end value
  19. ;;;   :y-start           - vertical start value
  20. ;;;   :y-end             - vertical end value
  21. ;;;   :n-bins            - number of columns to display
  22. ;;;   :bin-increment     - size (range) of data values for each bin
  23. ;;;   :bin-color         - column color
  24. ;;;   :bin-thickness     - 3D thickness of each bin
  25. ;;;   :value-fn          - function to return the data value of an
  26. ;;;                        event given the event
  27. ;;;
  28. ;;; set-histogram-data    - add a set of data points to the view
  29. ;;; set-histogram-range   - set the view's horizontal and vertical range.
  30. ;;;                         histogram's vertical range is always anchored
  31. ;;;                         at 0
  32. ;;;
  33. ;;; HISTORY:
  34. ;;;
  35. ;;; 6/15/92 Created.  - PM
  36. ;;; 
  37.  
  38. (in-package :ccl)
  39.  
  40. (require :perspective-projection)
  41. (require :GWorld-view-extensions)
  42.  
  43. (eval-when (:compile-toplevel :load-toplevel :execute)
  44.   (export '(histogram-view set-histogram-data set-histogram-range)))
  45.  
  46.  
  47. (defstruct bin
  48.   (start 0 :type fixnum)
  49.   (end 0 :type fixnum)
  50.   (size 0 :type fixnum))
  51.  
  52.  
  53. (defclass histogram-view (view)
  54.   ((x-scale :initarg :x-scale :accessor x-scale)
  55.    (y-scale :initarg :y-scale :accessor y-scale)
  56.    (x-start :initarg :x-start :accessor x-start)
  57.    (y-start :initarg :y-start :accessor y-start)
  58.    (x-end :initarg :x-end :accessor x-end)
  59.    (y-end :initarg :y-end :accessor y-end)
  60.    (n-bins :initarg :n-bins :accessor n-bins)
  61.    (bins :accessor bins)
  62.    (bin-increment :initarg :bin-increment :accessor bin-increment)
  63.    (bin-color :initarg :bin-color :accessor bin-color)
  64.    (bin-thickness :initarg :bin-thickness :accessor bin-thickness)
  65.    (perspective :initarg :perspective :accessor perspective)
  66.    (value-fn :initarg :value-fn :accessor value-fn))
  67.   (:default-initargs
  68.     :x-start 0
  69.     :x-end 10
  70.     :y-start 0
  71.     :y-end 10
  72.     :x-scale 1
  73.     :y-scale 1
  74.     :n-bins 6
  75.     :bin-increment 10
  76.     :bin-color *green-color*
  77.     :bin-thickness 7
  78.     :perspective (make-perspective)
  79.     :value-fn #'identity
  80.     )
  81.   )
  82.  
  83.  
  84. (defmethod initialize-instance ((view histogram-view) &rest initargs)
  85.   (apply #'call-next-method view initargs)
  86.   (make-histogram-bins view)
  87.   (set-3D-origin view) )
  88.  
  89.  
  90. (defmethod view-draw-contents ((view histogram-view))
  91.   (let* ((pos (view-scroll-position view))
  92.          (size (view-size view))
  93.          (top (point-v pos))
  94.          (left (point-h pos))
  95.          (bottom (+ top (point-v size)))
  96.          (right (+ left (point-h size))))
  97.     (with-GWorld-no-colorization (view left top right bottom)
  98.       (dotimes (i (n-bins view))
  99.         (let* ((bin (aref (bins view) i))
  100.                (start (bin-start bin))
  101.                (end (bin-end bin))
  102.                (size (bin-size bin))
  103.                (start-x (round (* start (x-scale view))))
  104.                (end-x (round (* end (x-scale view))))
  105.                (height (round (* size (y-scale view))))
  106.                (bottom (point-v (view-size view))))
  107.           (draw-block-below-horizon 
  108.            *GW-offscreen-view*
  109.            (perspective view)
  110.            (make-GW-point (+ (bin-thickness view) start-x) (- bottom height))
  111.            (make-GW-point (- end-x (bin-thickness view)) bottom)
  112.            (bin-color view)
  113.            (bin-thickness view)) ))) ))
  114.  
  115.  
  116. (defmethod set-view-size ((view histogram-view) h &optional v)
  117.   (call-next-method view h v)
  118.   (set-histogram-range view (x-start view) (x-end view) (y-end view)) )
  119.  
  120.  
  121. (defmethod set-3D-origin ((view histogram-view))
  122.   (setf (perspective-view-3D-origin (perspective view))
  123.         (make-point (+ (point-h (view-scroll-position view))
  124.                        (round (point-h (view-size view)) 2))
  125.                     (point-v (view-scroll-position view)))))
  126.  
  127.  
  128. (defmethod make-histogram-bins ((view histogram-view))
  129.   (setf (bins view) (make-array (list (n-bins view)) :element-type 'bin))
  130.   (dotimes (i (n-bins view))
  131.     (setf (aref (bins view) i) 
  132.           (make-bin 
  133.            :start (* i (bin-increment view))
  134.            :end (1- (* (1+ i) (bin-increment view))) ))))
  135.  
  136.  
  137. (defmethod set-histogram-range ((view histogram-view) x-start x-end y-end)
  138.   (let* ((old-x-scale (x-scale view))
  139.          (old-y-scale (y-scale view))
  140.          (x-scale (/ (point-h (view-size view)) (- x-end x-start)))
  141.          (y-scale (/ (point-v (view-size view)) y-end))
  142.          (scroll-position (view-scroll-position view))
  143.          (x-scroll (round (* x-scale x-start))))
  144.     (setf (x-start view) x-start)
  145.     (setf (x-end view) x-end)
  146.     (setf (y-end view) y-end)
  147.     (setf (x-scale view) x-scale)
  148.     (setf (y-scale view) y-scale)
  149.     
  150.     (when (or (/= x-scroll (point-h scroll-position))
  151.               (/= x-scale old-x-scale)
  152.               (/= y-scale old-y-scale))
  153.       (setf (view-scroll-position view) (make-point x-scroll 0))
  154.       (set-3D-origin view)
  155.       (invalidate-view view)
  156.       (set-view-scroll-position view x-scroll 0 t) ) ))
  157.  
  158.  
  159.  
  160. ;;;;
  161. ;;;; EXTERNAL DATA I/O
  162. ;;;;
  163.  
  164. (defmethod set-histogram-data ((view histogram-view) data-list)
  165.   (dotimes (i (n-bins view))
  166.     (let ((bin (aref (bins view) i)))
  167.       (setf (bin-size bin) 0)))
  168.   (dolist (data data-list)
  169.    (dotimes (i (n-bins view))
  170.     (let ((bin (aref (bins view) i))
  171.           (value (funcall (value-fn view) data)))
  172.       (if (<= (bin-start bin) value (bin-end bin))
  173.         (incf (bin-size bin))) )))
  174.   (invalidate-view view t) )
  175.  
  176.  
  177. (provide :histogram-view)